home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / sbin / update-binfmts < prev    next >
Encoding:
Text File  |  2008-05-26  |  19.3 KB  |  719 lines
  1. #! /usr/bin/perl -w
  2.  
  3. # Copyright (c) 2000, 2001, 2002 Colin Watson <cjwatson@debian.org>.
  4. # See update-binfmts(8) for documentation.
  5. #
  6. # This program is free software; you can redistribute it and/or modify
  7. # it under the terms of the GNU General Public License as published by
  8. # the Free Software Foundation; either version 2 of the License, or
  9. # (at your option) any later version.
  10. #
  11. # This program is distributed in the hope that it will be useful,
  12. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. # GNU General Public License for more details.
  15. #
  16. # You should have received a copy of the GNU General Public License
  17. # along with this program; if not, write to the Free Software
  18. # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  19.  
  20. use strict;
  21.  
  22. use POSIX qw(uname);
  23. use Text::Wrap;
  24. use Binfmt::Lib qw($admindir $importdir $procdir $auxdir quit warning);
  25. use Binfmt::Format;
  26.  
  27. my $VERSION = '1.2.11';
  28.  
  29. $Text::Wrap::columns = 79;
  30.  
  31. use vars qw($test);
  32.  
  33. my $register = "$procdir/register";
  34. my $status = "$procdir/status";
  35. my $run_detectors = "$auxdir/run-detectors";
  36.  
  37. my %formats;
  38.  
  39. # Various "print something and exit" routines.
  40.  
  41. sub version ()
  42. {
  43.     print "update-binfmts $VERSION.\n"
  44.     or die "unable to write version message: $!";
  45. }
  46.  
  47. sub usage ()
  48. {
  49.     version;
  50.     print <<EOF
  51. Copyright (c) 2000, 2001, 2002 Colin Watson. This is free software; see
  52. the GNU General Public License version 2 or later for copying conditions.
  53.  
  54. Usage:
  55.  
  56.   update-binfmts [options] --install <name> <path> <spec>
  57.   update-binfmts [options] --remove <name> <path>
  58.   update-binfmts [options] --import [<name>]
  59.   update-binfmts [options] --display [<name>]
  60.   update-binfmts [options] --enable [<name>]
  61.   update-binfmts [options] --disable [<name>]
  62.  
  63.   where <spec> is one of:
  64.  
  65.     --magic <byte-sequence> [--mask <byte-sequence>] [--offset <offset>]
  66.     --extension <extension>
  67.  
  68.   The following argument may be added to any <spec> to have a userspace
  69.   process determine whether the file should be handled:
  70.  
  71.     --detector <path>
  72.  
  73. Options:
  74.  
  75.     --package <package-name>    for --install and --remove, specify the
  76.                                 current package name
  77.     --admindir <directory>      use <directory> instead of /var/lib/binfmts
  78.                                 as administration directory
  79.     --importdir <directory>     use <directory> instead of /usr/share/binfmts
  80.                                 as import directory
  81.     --test                      don't do anything, just demonstrate
  82.     --help                      print this help screen and exit
  83.     --version                   output version and exit
  84.  
  85. EOF
  86.     or die "unable to write usage message: $!";
  87. }
  88.  
  89. sub usage_quit ($;@)
  90. {
  91.     my $me = $0;
  92.     $me =~ s#.*/##;
  93.     print STDERR wrap '', '', "$me:", @_, "\n";
  94.     usage;
  95.     exit 2;
  96. }
  97.  
  98. sub check_supported_os ()
  99. {
  100.     my $sysname = (uname)[0];
  101.     return if $sysname eq 'Linux';
  102.     print <<EOF;
  103. Sorry, update-binfmts currently only works on Linux.
  104. EOF
  105.     if ($sysname eq 'GNU') {
  106.     print <<EOF;
  107. Patches for Hurd support are welcomed; they should not be difficult.
  108. EOF
  109.     }
  110.     exit 2;
  111. }
  112.  
  113. # Make sure options are unambiguous.
  114.  
  115. sub check_modes ($$)
  116. {
  117.     return unless $_[0];
  118.     usage_quit "two modes given: --$_[0] and $_[1]";
  119. }
  120.  
  121. sub check_types ($$)
  122. {
  123.     return unless $_[0];
  124.     usage_quit "two binary format specifications given: --$_[0] and $_[1]";
  125. }
  126.  
  127. sub rename_mv ($$)
  128. {
  129.     my ($source, $dest) = @_;
  130.     return (rename($source, $dest) || (system('mv', $source, $dest) == 0));
  131. }
  132.  
  133. sub get_import ($)
  134. {
  135.     my $name = shift;
  136.     my %import;
  137.     local *IMPORT;
  138.     unless (open IMPORT, "< $name") {
  139.     warning "unable to open $name: $!";
  140.     return;
  141.     }
  142.     local $_;
  143.     while (<IMPORT>) {
  144.     chomp;
  145.     my ($name, $value) = split ' ', $_, 2;
  146.     $import{lc $name} = $value;
  147.     }
  148.     close IMPORT;
  149.     return %import;
  150. }
  151.  
  152. # Loading and unloading logic, which should cope with the various ways this
  153. # has been implemented.
  154.  
  155. sub get_binfmt_style ()
  156. {
  157.     my $style;
  158.     local *FS;
  159.     unless (open FS, '/proc/filesystems') {
  160.     # Weird. Assume procfs.
  161.     warning "unable to open /proc/filesystems: $!";
  162.     return 'procfs';
  163.     }
  164.     if (grep m/\bbinfmt_misc\b/, <FS>) {
  165.     # As of 2.4.3, the official Linux kernel still uses the original
  166.     # interface, but Alan Cox's patches add a binfmt_misc filesystem
  167.     # type which needs to be mounted separately. This may get into the
  168.     # official kernel in the future, so support both.
  169.     $style = 'filesystem';
  170.     } else {
  171.     # The traditional interface.
  172.     $style = 'procfs';
  173.     }
  174.     close FS;
  175.     return $style;
  176. }
  177.  
  178. sub load_binfmt_misc ()
  179. {
  180.     if ($test) {
  181.     print "load binfmt_misc\n";
  182.     return 1;
  183.     }
  184.  
  185.     my $style = get_binfmt_style;
  186.     # If the style is 'filesystem', then we must already have the module
  187.     # loaded, as binfmt_misc wouldn't show up in /proc/filesystems
  188.     # otherwise.
  189.     if ($style eq 'procfs' and not -f $register) {
  190.     if (not -x '/sbin/modprobe' or system qw(/sbin/modprobe binfmt_misc)) {
  191.         warning "Couldn't load the binfmt_misc module.";
  192.         return 0;
  193.     }
  194.     }
  195.  
  196.     unless (-d $procdir) {
  197.     warning "binfmt_misc module seemed to be loaded, but no $procdir",
  198.         "directory! Giving up.";
  199.     return 0;
  200.     }
  201.  
  202.     # Find out what the style looks like now.
  203.     $style = get_binfmt_style;
  204.     if ($style eq 'filesystem' and not -f $register) {
  205.     if (system ('/bin/mount', '-t', 'binfmt_misc',
  206.             '-o', 'nodev,noexec,nosuid', 'binfmt_misc', $procdir)) {
  207.         warning "Couldn't mount the binfmt_misc filesystem on $procdir.";
  208.         return 0;
  209.     }
  210.     }
  211.  
  212.     if (-f $register) {
  213.     local *STATUS;
  214.     if (open STATUS, "> $status") {
  215.         print STATUS "1\n";
  216.         close STATUS;
  217.     } else {
  218.         warning "unable to open $status for writing: $!";
  219.     }
  220.     return 1;
  221.     } else {
  222.     warning "binfmt_misc initialized, but $register missing! Giving up.";
  223.     return 0;
  224.     }
  225. }
  226.  
  227. sub unload_binfmt_misc ()
  228. {
  229.     my $style = get_binfmt_style;
  230.  
  231.     if ($test) {
  232.     print "unload binfmt_misc ($style)\n";
  233.     return 1;
  234.     }
  235.  
  236.     if ($style eq 'filesystem') {
  237.     if (system '/bin/umount', $procdir) {
  238.         warning "Couldn't unmount the binfmt_misc filesystem from",
  239.             "$procdir.";
  240.         return 0;
  241.     }
  242.     }
  243.     # We used to try to unload the kernel module as well, but it seems that
  244.     # it doesn't always unload properly (http://bugs.debian.org/155570) and
  245.     # in any case it means that strictly speaking we have to remember if the
  246.     # module was loaded when we started. Since it's not actually important,
  247.     # we now just don't bother.
  248.     return 1;
  249. }
  250.  
  251. # Actions.
  252.  
  253. # Enable a binary format in the kernel.
  254. sub act_enable (;$);
  255. sub act_enable (;$)
  256. {
  257.     my $name = shift;
  258.     return 1 unless load_binfmt_misc;
  259.     if (defined $name) {
  260.     unless ($test or exists $formats{$name}) {
  261.         warning "$name not in database of installed binary formats.";
  262.         return 0;
  263.     }
  264.     my $binfmt = $formats{$name};
  265.     my $type = ($binfmt->{type} eq 'magic') ? 'M' : 'E';
  266.  
  267.     my $need_detector = (defined $binfmt->{detector} and
  268.                  length $binfmt->{detector}) ? 1 : 0;
  269.     unless ($need_detector) {
  270.         # Scan the format database to see if anything else uses the same
  271.         # spec as us. If so, assume that we need a detector, effectively
  272.         # /bin/true. Don't actually set $binfmt->{detector} though,
  273.         # since run-detectors optimizes the case of empty detectors and
  274.         # "runs" them last.
  275.         for my $id (keys %formats) {
  276.         next if $id eq $name;
  277.         if ($binfmt->equals ($formats{$id})) {
  278.             $need_detector = 1;
  279.             last;
  280.         }
  281.         }
  282.     }
  283.     # Fake the interpreter if we need a userspace detector program.
  284.     my $interpreter = $need_detector ? $run_detectors
  285.                      : $binfmt->{interpreter};
  286.  
  287.     my $regstring = ":$name:$type:$binfmt->{offset}:$binfmt->{magic}" .
  288.             ":$binfmt->{mask}:$interpreter:\n";
  289.     if ($test) {
  290.         print "enable $name with the following format string:\n",
  291.           " $regstring";
  292.     } else {
  293.         local *REGISTER;
  294.         unless (open REGISTER, ">$register") {
  295.         warning "unable to open $register for writing: $!";
  296.         return 0;
  297.         }
  298.         print REGISTER $regstring;
  299.         unless (close REGISTER) {
  300.         warning "unable to close $register: $!";
  301.         return 0;
  302.         }
  303.     }
  304.     return 1;
  305.     } else {
  306.     my $worked = 1;
  307.     for my $id (keys %formats) {
  308.         unless (-e "$procdir/$id") {
  309.         $worked &= act_enable $id;
  310.         }
  311.     }
  312.     return $worked;
  313.     }
  314. }
  315.  
  316. # Disable a binary format in the kernel.
  317. sub act_disable (;$);
  318. sub act_disable (;$)
  319. {
  320.     my $name = shift;
  321.     return 1 unless -d $procdir;    # We're disabling anyway, so we don't mind
  322.     if (defined $name) {
  323.     unless (-e "$procdir/$name") {
  324.         # Don't warn in this circumstance, as it could happen e.g. when
  325.         # binfmt-support and a package depending on it are upgraded at
  326.         # the same time, so we get called when stopped. Just pretend
  327.         # that the disable operation succeeded.
  328.         return 1;
  329.     }
  330.  
  331.     # We used to check the entry in $procdir to make sure we were
  332.     # removing an entry with the same interpreter, but this is bad; it
  333.     # makes things really difficult for packages that want to change
  334.     # their interpreter, for instance. Now we unconditionally remove and
  335.     # rely on the calling logic to check that the entry in $admindir
  336.     # belongs to the same package.
  337.     # 
  338.     # In other words, $admindir becomes the canonical reference, not
  339.     # $procdir. This is in line with similar update-* tools in Debian.
  340.  
  341.     if ($test) {
  342.         print "disable $name\n";
  343.     } else {
  344.         local *PROCENTRY;
  345.         unless (open PROCENTRY, ">$procdir/$name") {
  346.         warning "unable to open $procdir/$name for writing: $!";
  347.         return 0;
  348.         }
  349.         print PROCENTRY -1;
  350.         unless (close PROCENTRY) {
  351.         warning "unable to close $procdir/$name: $!";
  352.         return 0;
  353.         }
  354.         if (-e "$procdir/$name") {
  355.         warning "removal of $procdir/$name ignored by kernel!";
  356.         return 0;
  357.         }
  358.     }
  359.     return 1;
  360.     }
  361.     else
  362.     {
  363.     my $worked = 1;
  364.     for my $id (keys %formats) {
  365.         if (-e "$procdir/$id") {
  366.         $worked &= act_disable $id;
  367.         }
  368.     }
  369.     unload_binfmt_misc;    # ignore errors here
  370.     return $worked;
  371.     }
  372. }
  373.  
  374. # Install a binary format into binfmt-support's database. Attempt to enable
  375. # the new format in the kernel as well.
  376. sub act_install ($$)
  377. {
  378.     my $name = shift;
  379.     my $binfmt = shift;
  380.     if (exists $formats{$name}) {
  381.     # For now we just silently zap any old versions with the same
  382.     # package name (has to be silent or upgrades are annoying). Maybe we
  383.     # should be more careful in the future.
  384.     my $package = $binfmt->{package};
  385.     my $old_package = $formats{$name}{package};
  386.     unless ($package eq $old_package) {
  387.         $package     = '<local>' if $package eq ':';
  388.         $old_package = '<local>' if $old_package eq ':';
  389.         warning "current package is $package, but binary format already",
  390.             "installed by $old_package";
  391.         return 0;
  392.     }
  393.     unless (act_disable $name) {
  394.         warning "unable to disable binary format $name";
  395.         return 0;
  396.     }
  397.     }
  398.     if (-e "$procdir/$name" and not $test) {
  399.     # This is a bit tricky. If we get here, then the kernel knows about
  400.     # a format we don't. Either somebody has used binfmt_misc directly,
  401.     # or update-binfmts did something wrong. For now we do nothing;
  402.     # disabling and re-enabling all binary formats will fix this anyway.
  403.     # There may be a --force option in the future to help with problems
  404.     # like this.
  405.     # 
  406.     # Disabled for --test, because otherwise it never works; the
  407.     # vagaries of binfmt_misc mean that it isn't really possible to find
  408.     # out from userspace exactly what's going to happen if people have
  409.     # been bypassing update-binfmts.
  410.     warning "found manually created entry for $name in $procdir;",
  411.         "leaving it alone";
  412.     return 1;
  413.     }
  414.  
  415.     if ($test) {
  416.     print "install the following binary format description:\n";
  417.     $binfmt->dump_stdout;
  418.     } else {
  419.     $binfmt->write ("$admindir/$name.tmp") or return 0;
  420.     unless (rename_mv "$admindir/$name.tmp", "$admindir/$name") {
  421.         warning "unable to install $admindir/$name.tmp as",
  422.             "$admindir/$name: $!";
  423.         return 0;
  424.     }
  425.     }
  426.     $formats{$name} = $binfmt;
  427.     unless (act_enable $name) {
  428.     warning "unable to enable binary format $name";
  429.     return 0;
  430.     }
  431.     return 1;
  432. }
  433.  
  434. # Remove a binary format from binfmt-support's database. Attempt to disable
  435. # the format in the kernel first.
  436. sub act_remove ($$)
  437. {
  438.     my $name = shift;
  439.     my $package = shift;
  440.     unless (exists $formats{$name}) {
  441.     # There may be a --force option in the future to allow entries like
  442.     # this to be removed; either they were created manually or
  443.     # update-binfmts was broken.
  444.     warning "$admindir/$name does not exist; nothing to do!";
  445.     return 0;
  446.     }
  447.     my $old_package = $formats{$name}{package};
  448.     unless ($package eq $old_package) {
  449.     $package     = '<local>' if $package eq ':';
  450.     $old_package = '<local>' if $old_package eq ':';
  451.     warning "current package is $package, but binary format already",
  452.         "installed by $old_package; not removing.";
  453.     # I don't think this should be fatal.
  454.     return 1;
  455.     }
  456.     unless (act_disable $name) {
  457.     warning "unable to disable binary format $name";
  458.     return 0;
  459.     }
  460.     if ($test) {
  461.     print "remove $admindir/$name\n";
  462.     } else {
  463.     unless (unlink "$admindir/$name") {
  464.         warning "unable to remove $admindir/$name: $!";
  465.         return 0;
  466.     }
  467.     delete $formats{$name};
  468.     }
  469.     return 1;
  470. }
  471.  
  472. # Import a new format file into binfmt-support's database. This is intended
  473. # for use by packaging systems.
  474. sub act_import (;$);
  475. sub act_import (;$)
  476. {
  477.     my $name = shift;
  478.     if (defined $name) {
  479.     my $id;
  480.     if ($name =~ m!.*/(.*)!) {
  481.         $id = $1;
  482.     } else {
  483.         $id = $name;
  484.         $name = "$importdir/$name";
  485.     }
  486.  
  487.     if ($id =~ /^(\.\.?|register|status)$/) {
  488.         warning "binary format name '$id' is reserved";
  489.         return 0;
  490.     }
  491.  
  492.     my %import = get_import $name;
  493.     unless (scalar keys %import) {
  494.         warning "couldn't find information about '$id' to import";
  495.         return 0;
  496.     }
  497.  
  498.     if (exists $formats{$id}) {
  499.         if ($formats{$id}{package} eq ':') {
  500.         # Installed version was installed manually, so don't import
  501.         # over it.
  502.         warning "preserving local changes to $id";
  503.         return 1;
  504.         } else {
  505.         # Installed version was installed by a package, so it should
  506.         # be OK to replace it.
  507.         }
  508.     }
  509.  
  510.     # TODO: This duplicates the verification code below slightly.
  511.     unless (defined $import{package}) {
  512.         warning "$name: required 'package' line missing";
  513.         return 0;
  514.     }
  515.  
  516.     unless (-x $import{interpreter}) {
  517.         warning "$name: no executable $import{interpreter} found, but",
  518.             "continuing anyway as you request";
  519.     }
  520.  
  521.     act_install $id, Binfmt::Format->new ($name, %import);
  522.     return 1;
  523.     } else {
  524.     local *IMPORTDIR;
  525.     unless (opendir IMPORTDIR, $importdir) {
  526.         warning "unable to open $importdir: $!";
  527.         return 0;
  528.     }
  529.     my $worked = 1;
  530.     for (readdir IMPORTDIR) {
  531.         next unless -f "$importdir/$_";
  532.         if (-f "$importdir/$_") {
  533.         $worked &= act_import $_;
  534.         }
  535.     }
  536.     closedir IMPORTDIR;
  537.     return $worked;
  538.     }
  539. }
  540.  
  541. # Display a format stored in binfmt-support's database.
  542. sub act_display (;$);
  543. sub act_display (;$)
  544. {
  545.     my $name = shift;
  546.     if (defined $name) {
  547.     print "$name (", (-e "$procdir/$name" ? 'enabled' : 'disabled'),
  548.           "):\n";
  549.     my $binfmt = $formats{$name};
  550.     my $package = $binfmt->{package} eq ':' ? '<local>'
  551.                         : $binfmt->{package};
  552.     print <<EOF;
  553.      package = $package
  554.         type = $binfmt->{type}
  555.       offset = $binfmt->{offset}
  556.        magic = $binfmt->{magic}
  557.         mask = $binfmt->{mask}
  558.  interpreter = $binfmt->{interpreter}
  559.     detector = $binfmt->{detector}
  560. EOF
  561.     } else {
  562.     for my $id (keys %formats) {
  563.         act_display $id;
  564.     }
  565.     }
  566.     return 1;
  567. }
  568.  
  569. # Now go.
  570.  
  571. check_supported_os;
  572.  
  573. my @modes = qw(install remove import display enable disable);
  574. my @types = qw(magic extension);
  575.  
  576. my ($package, $name);
  577. my ($mode, $type);
  578. my %spec;
  579.  
  580. my %unique_options = (
  581.     'package'    => \$package,
  582.     'mask'    => \$spec{mask},
  583.     'offset'    => \$spec{offset},
  584.     'detector'  => \$spec{detector},
  585. );
  586.  
  587. my %arguments = (
  588.     'admindir'    => ['path' => \$admindir],
  589.     'importdir'    => ['path' => \$importdir],
  590.     'install'    => ['name' => \$name, 'path' => \$spec{interpreter}],
  591.     'remove'    => ['name' => \$name, 'path' => \$spec{interpreter}],
  592.     'package'    => ['package-name' => \$package],
  593.     'magic'    => ['byte-sequence' => \$spec{magic}],
  594.     'extension'    => ['extension' => \$spec{extension}],
  595.     'mask'    => ['byte-sequence' => \$spec{mask}],
  596.     'offset'    => ['offset' => \$spec{offset}],
  597.     'detector'  => ['path' => \$spec{detector}],
  598. );
  599.  
  600. my %parser = (
  601.     'help'    => sub { usage; exit 0; },
  602.     'version'    => sub { version; exit 0; },
  603.     'test'    => sub { $test = 1; },
  604.     'install'    => sub {
  605.     -x $spec{interpreter}
  606.         or warning "no executable $spec{interpreter} found, but",
  607.                "continuing anyway as you request";
  608.     },
  609.     'remove'    => sub {
  610.     -x $spec{interpreter}
  611.         or warning "no executable $spec{interpreter} found, but",
  612.                "continuing anyway as you request";
  613.     },
  614.     'import'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  615.     'display'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  616.     'enable'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  617.     'disable'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  618.     'offset'    => sub {
  619.     $spec{offset} =~ /^\d+$/
  620.         or usage_quit 'offset must be a whole number';
  621.     },
  622.     'detector'  => sub {
  623.     -x $spec{detector}
  624.         or warning "no executable $spec{detector} found, but",
  625.                "continuing anyway as you request";
  626.     },
  627. );
  628.  
  629. while (defined($_ = shift))
  630. {
  631.     last if /^--$/;
  632.     if (!/^--(.+)$/) {
  633.     usage_quit "unknown argument '$_'";
  634.     }
  635.     my $option = $1;
  636.     my $is_mode = grep { $_ eq $option } @modes;
  637.     my $is_type = grep { $_ eq $option } @types;
  638.     my $has_args = exists $arguments{$option};
  639.  
  640.     unless ($is_mode or $is_type or $has_args or exists $parser{$option}) {
  641.     usage_quit "unknown argument '$_'";
  642.     }
  643.  
  644.     check_modes $mode, $option if $is_mode;
  645.     check_types $type, $option if $is_type;
  646.  
  647.     if (exists $unique_options{$option} and
  648.     defined ${$unique_options{$option}}) {
  649.     usage_quit "more than one --$option option given";
  650.     }
  651.  
  652.     if ($has_args) {
  653.     my (@descs, @varrefs);
  654.     # Split into descriptions and variable references.
  655.     my $alt = 0;
  656.     foreach my $arg (@{$arguments{$option}}) {
  657.         if (($alt = !$alt))    { push @descs, "<$arg>"; }
  658.         else        { push @varrefs, $arg; }
  659.     }
  660.     usage_quit "--$option needs @descs" unless @ARGV >= @descs;
  661.     foreach my $varref (@varrefs) { $$varref = shift @ARGV; }
  662.     }
  663.  
  664.     &{$parser{$option}} if defined $parser{$option};
  665.  
  666.     $mode = $option if $is_mode;
  667.     $type = $option if $is_type;
  668. }
  669.  
  670. $package = ':' unless defined $package;
  671.  
  672. unless (defined $mode) {
  673.     usage_quit 'you must use one of --install, --remove, --import, --display,',
  674.            '--enable, --disable';
  675. }
  676.  
  677. my $binfmt;
  678. if ($mode eq 'install') {
  679.     defined $type or usage_quit '--install requires a <spec> option';
  680.     if ($name =~ /^(\.\.?|register|status)$/) {
  681.     usage_quit "binary format name '$name' is reserved";
  682.     }
  683.     $binfmt = Binfmt::Format->new ($name, package => $package, type => $type,
  684.                    %spec);
  685. }
  686.  
  687. local *ADMINDIR;
  688. unless (opendir ADMINDIR, $admindir) {
  689.     quit "unable to open $admindir: $!";
  690. }
  691. for my $name (readdir ADMINDIR) {
  692.     if (-f "$admindir/$name") {
  693.     my $format = Binfmt::Format->load ($name, "$admindir/$name");
  694.     $formats{$name} = $format if defined $format;
  695.     }
  696. }
  697. closedir ADMINDIR;
  698.  
  699. my %actions = (
  700.     'install'    => [\&act_install, $binfmt],
  701.     'remove'    => [\&act_remove, $package],
  702.     'import'    => [\&act_import],
  703.     'display'    => [\&act_display],
  704.     'enable'    => [\&act_enable],
  705.     'disable'    => [\&act_disable],
  706. );
  707.  
  708. unless (exists $actions{$mode}) {
  709.     usage_quit "unknown mode: $mode";
  710. }
  711.  
  712. my @actargs = @{$actions{$mode}};
  713. my $actsub = shift @actargs;
  714. if ($actsub->($name, @actargs)) {
  715.     exit 0;
  716. } else {
  717.     quit 'exiting due to previous errors';
  718. }
  719.